home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / textyl / psrc / textyl.pas.ae < prev    next >
Text File  |  1993-11-07  |  31KB  |  1,001 lines
  1.    if (figdepth = 0) then 
  2.      begin      (* ---- do the primitive by itself *)
  3.       (* re-transform it to the 4th Quadrant *)
  4.      dvilinepts (x1, y1, x2, y2, h, v);  (* global h and v posit *)
  5.      IPUSH;
  6.      TylLine (x1, y1, x2, y2, thk, vk, patt);
  7.      IPOP;
  8.      end
  9.   else if (figdepth > 0) then
  10.      begin      (* ---- Pack it and stack it *)
  11.      lineitem := NewItem (Aline);
  12.      with lineitem^ do
  13.        begin
  14.        BBlx := minx;     BBby := miny;
  15.        BBrx := maxx;     BBty := maxy;
  16.        lx1 := x1;     ly1 := y1;
  17.        lx2 := x2;    ly2 := y2;
  18.        itemthick := thk;
  19.        itemvec := vk;
  20.        itempatt := patt;
  21.        end;  
  22.      pushItem (figdepth, lineitem);
  23.      end
  24.    else if (figdepth < 0) then
  25.      begin      (* ---- just do it right away without any PUSH/POP pair *)
  26.              (* this is the case when we are unpacking a figure for
  27.          *  immediate output
  28.          *)
  29.      TylLine (x1, y1, x2, y2, thk, vk, patt);
  30.      end;  
  31. end;  (*  linehandle *)
  32.  
  33.  
  34. (* ---   Simple Splines -----*)
  35. {-----------------------------------------------------}
  36. procedure splinehandle (figdepth : integer; scalefact : real;
  37.                         thetype : SplineKind; isclosed : boolean;
  38.             markdiam : integer;
  39.                         var contpts : ControlPoints;
  40.                         nknots : integer;
  41.                         dvih, dviv : ScaledPts; (* possible dvi-offsets *)
  42.                         thk : VThickness; vec : VectKind;
  43.             patt : LineStyle;
  44.                         minx, maxx, miny, maxy : ScaledPts;
  45.                         tx, ty : ScaledPts; sx, sy, r : real);
  46. var midx, midy : ScaledPts;                     
  47.     splineitem : pItem;
  48.     i : integer;
  49. begin
  50.    midx := (minx + maxx) div 2;
  51.    midy := (miny + maxy) div 2;
  52.    
  53.    xfmcontpts (contpts, nknots, dvih, dviv, midx, midy,
  54.                 scalefact, r, tx, ty, sx, sy);
  55.  
  56.    if (figdepth = 0) then
  57.      begin      (* ----  do the primitive *)
  58.      (* transform to 4th quad *)
  59.      dvicontpts (contpts, nknots, h, v);
  60.      IPUSH;
  61.      TylSpline (thetype, isclosed, contpts, nknots, thk, vec, patt, markdiam);
  62.      IPOP;
  63.      end
  64.    else if (figdepth > 0) then
  65.      begin
  66.      splineitem := NewItem (Aspline);
  67.      with splineitem^ do
  68.        begin
  69.        BBlx := minx; BBby := miny;
  70.        BBrx := maxx; BBty := maxy;
  71.        itemthick := thk;
  72.        itemvec := vec;
  73.        itempatt := patt;
  74.        nsplknots := nknots;
  75.        spltype := thetype;
  76.        sclosed := isclosed;
  77.        dosmarks := markdiam;
  78.        for i := 1 to nknots do
  79.          begin
  80.          spts[i,1] := contpts[i,1];
  81.          spts[i,2] := contpts[i,2];
  82.          end;
  83.        end;  
  84.      pushItem (figdepth, splineitem);
  85.      end
  86.    else if (figdepth < 0) then
  87.      begin
  88.      TylSpline (thetype, isclosed, contpts, nknots, thk, vec, patt, markdiam);
  89.      end;  
  90. end;  (*  splinehandle *)
  91.  
  92.  
  93. (* --- Variable thickness splines ----- *)
  94. {-----------------------------------------------------}
  95. procedure ttsplhandle (figdepth : integer; scalefact : real;
  96.                         thetype : SplineKind; isclosed : boolean;
  97.             markdiam : integer;
  98.                         contpts : ControlPoints;
  99.                         ttks : ThickAryType;
  100.                         nknots : integer; 
  101.                         dvih, dviv : ScaledPts; (* possible dvi-offsets *)
  102.                         vec : VectKind;
  103.             patt : LineStyle;
  104.                         minx, maxx, miny, maxy : ScaledPts;
  105.                         tx, ty : ScaledPts; sx, sy, r : real);
  106. var midx, midy : ScaledPts;
  107.     ttsplitem : pItem;
  108.     i : integer;
  109. begin
  110.    midx := (minx + maxx) div 2;
  111.    midy := (miny + maxy) div 2;
  112.    
  113.    xfmcontpts (contpts, nknots, dvih, dviv, midx, midy,
  114.                 scalefact, r, tx, ty, sx, sy);
  115.  
  116.    if (figdepth = 0) then
  117.      begin
  118.      (* transform to 4th quad      *)
  119.      dvicontpts (contpts, nknots, h, v);
  120.      IPUSH;
  121.      TylThickThinSpline (thetype, isclosed, contpts, ttks, nknots, vec, patt, markdiam);
  122.      IPOP;
  123.      end
  124.    else if (figdepth > 0) then
  125.      begin
  126.      ttsplitem := NewItem (Attspline);
  127.      with ttsplitem^ do
  128.        begin
  129.        BBlx := minx; BBby := miny;
  130.        BBrx := maxx; BBty := maxy;
  131.        itemvec := vec;
  132.        itempatt := patt;
  133.        nttknots := nknots;
  134.        tspltype := thetype;
  135.        dottmarks := markdiam;
  136.        tclosed := isclosed;
  137.        for i := 1 to nknots do
  138.          begin
  139.          ttpts[i,1] := contpts[i,1];
  140.          ttpts[i,2] := contpts[i,2];
  141.          ttarry[i] := ttks[i];
  142.          end;
  143.        end;  (*  ttsplitem *)
  144.      pushItem (figdepth, ttsplitem);
  145.      end
  146.    else if (figdepth < 0) then
  147.      begin
  148.      TylThickThinSpline (thetype, isclosed, contpts, ttks, nknots, vec, patt, markdiam);
  149.      end;  
  150.   
  151. end;  (*  ttsplhandle *)
  152.  
  153.  
  154. (* ---- Musical Beams ---- *)
  155. {-----------------------------------------------------}
  156. procedure beamhandle (depth, siz : integer; bk : BeamKind;
  157.                         x1, y1, x2, y2 : ScaledPts);
  158. var bmitem : pItem;
  159. begin
  160.     if (depth = 0) then
  161.       begin
  162.       dvilinepts (x1, y1, x2, y2, h, v);
  163.       IPUSH;
  164.       TylBeam (x1, y1, x2, y2, siz, bk);
  165.       IPOP;
  166.       end
  167.     else if (depth > 0) then
  168.       begin
  169.       bmitem := NewItem (Abeam);
  170.       with bmitem^ do
  171.         begin
  172.         BBlx := min(x1, x2);     BBby := min(y1, y2);
  173.         BBrx := max(x1, x2);     BBty := max(y1, y2);
  174.     bx1 := x1;        by1 := y1;
  175.     bx2 := x2;        by2 := y2;    
  176.         staf := siz;
  177.         bkind := bk;
  178.         end;  (* with *)
  179.       pushItem (depth, bmitem);
  180.       end
  181.     else if (depth < 0) then
  182.       begin
  183.       TylBeam (x1, y1, x2, y2, siz, bk);      
  184.       end;  (* else *)
  185. end;  (*  beamhandle *)
  186.  
  187.  
  188. (* ---- Musical Ties and Slurs ----- *)
  189. {-----------------------------------------------------}
  190. procedure tieslurhandle (depth: integer; pts : ControlPoints;
  191.                         numk : integer; minthick, maxthick : VThickness);
  192. var tsitem : pItem;
  193.     i : integer;
  194. begin
  195. if (depth = 0) then
  196.    begin
  197.      dvicontpts (pts, numk, h, v);
  198.      IPUSH;
  199.      TylTieSlur (pts, numk, minthick, maxthick);
  200.      IPOP;
  201.    end
  202. else if (depth > 0) then
  203.  begin
  204.   tsitem := NewItem (Atieslur);
  205.   with tsitem^ do
  206.     begin
  207.     ntknots := numk;
  208.     for i := 1 to numk do 
  209.       begin
  210.       tspts[i,1] := pts[i,1];
  211.       tspts[i,2] := pts[i,2];
  212.       end;
  213.     minth := minthick;
  214.     maxth := maxthick;
  215.     end;  (* with *)
  216.   pushItem (depth, tsitem);
  217.   end
  218. else if (depth < 0) then
  219.   begin
  220.   TylTieSlur (pts, numk, minthick, maxthick);      
  221.   end;  (* else *)
  222. end;  (*  tieslurhandle *)
  223.  
  224.  
  225. {---------------------------------------------------------}
  226. procedure arccirclehandle (figdepth : integer; scalefact : real;
  227.             cx, cy : ScaledPts;
  228.             radius : ScaledPts;
  229.             ang1, ang2 : integer;
  230.             var contpts : ControlPoints; (* IN *)
  231.             nknots : integer;
  232.             dvih, dviv : ScaledPts; (* possible dvi-offsets *)
  233.             thk : VThickness; vec : VectKind;
  234.             patt : LineStyle;
  235.             minx, maxx, miny, maxy : ScaledPts;
  236.             tx, ty : ScaledPts; sx, sy, r : real);
  237.  
  238. var midx, midy : ScaledPts;                     
  239.     middlex, middley : ScaledPts;
  240.     arcitem : pItem;
  241.     i : integer;
  242.     isclosedarc : boolean;
  243.  
  244. begin
  245.    midx := cx;  middlex := (minx + maxx) div 2;
  246.    midy := cy;    middley := (miny + maxy) div 2;
  247.    isclosedarc := (ang1 = ang2);
  248. {
  249.    if (isclosedarc) then
  250.      maxspanlen := round ((360.0 / 16.0) * DEGTORAD * radius)
  251.    else
  252.      maxspanlen := round ((abs(ang2 - ang1) / 16.0) * DEGTORAD * radius);
  253. { }
  254.  
  255.  
  256.    xfmcontpts (contpts, nknots+1, dvih, dviv, midx, midy,
  257.                 scalefact, r, tx, ty, sx, sy);
  258.  
  259.    if (figdepth = 0) then
  260.      begin      (* ---- just do the primitive *)
  261.      (* transform to 4th quad *)
  262.      dvicontpts (contpts, nknots+1, h, v);
  263.      IPUSH;
  264.      doTylArc (isclosedarc, 
  265.              contpts, nknots, thk, vec, patt); 
  266.      IPOP;
  267.      end
  268.    else if (figdepth > 0) then
  269.      begin
  270.      arcitem := NewItem (Aarc);
  271.      with arcitem^ do
  272.        begin
  273.        BBlx := minx; BBby := miny;
  274.        BBrx := maxx; BBty := maxy;
  275.        itemthick := thk;
  276.        itemvec := vec;
  277.        itempatt := patt;
  278.        narcknots := nknots;
  279.        acentx := cx;
  280.        acenty := cy;
  281.        aradius := radius;
  282.        firstang := ang1;
  283.        lastang := ang2;
  284.        for i := 0 to nknots+1 do
  285.          begin
  286.          arcpts[i,1] := contpts[i,1];
  287.          arcpts[i,2] := contpts[i,2];
  288.          end;
  289.        end;  
  290.      pushItem (figdepth, arcitem);
  291.      end
  292.    else if (figdepth < 0) then
  293.      begin
  294.      doTylArc (isclosedarc, contpts, nknots, thk, vec, patt);
  295.      end;  
  296. end;  (*  arccirclehandle *)
  297.  
  298.  
  299.  
  300. {---------------------------------------------------------}
  301. procedure labelhandle (depth : integer; scalefact: real; 
  302.                        lax, lay : ScaledPts;
  303.                        dvih, dviv : ScaledPts; (* possible dvi-offsets *)
  304.                style : integer; 
  305.                phrase : strng;
  306.                tx, ty : ScaledPts);
  307. var labitem : pItem;
  308.     null1, null2 : ScaledPts;
  309. begin
  310. (* xfm the label point if necessary *)
  311.   lax := lax + round(tx * scalefact);
  312.   lay := lay + round(ty * scalefact);
  313.  
  314.   if (depth = 0) then
  315.     begin
  316.     null1 := 0; null2 := 0;
  317.     dvilinepts (lax, lay, null1, null2, h, v);
  318.     IPUSH;
  319.     TylLabel (lax, lay, style, phrase.str, phrase.len);
  320.     IPOP;
  321.     end
  322.   else if (depth > 0) then
  323.     begin
  324.     labitem := NewItem (Alabel);
  325.     with labitem^ do
  326.       begin
  327.       labx := lax; 
  328.       laby := lay;
  329.       fontstyle := style;
  330.       strcopy (phrase.str, labeltext.str, phrase.len);
  331.       labeltext.len := phrase.len;
  332.       end;  
  333.     pushItem (depth, labitem);
  334.     end  
  335.   else if (depth < 0) then
  336.     begin
  337.     TylLabel (lax, lay, style, phrase.str, phrase.len);
  338.     end; 
  339. end;
  340.  
  341.  
  342. (* ####   Insert new handlers here for new "primitives"
  343.     i.e., names callable from the \special[tyl ...]  level 
  344. *)
  345.  
  346.  
  347.  
  348. {----------------------------------------------------------------}
  349. (*  transform the current bbox coordinates, and output the new one *)
  350. procedure newbbox (var minx, maxx, miny, maxy : ScaledPts;
  351.                    midx, midy : ScaledPts;
  352.                    sx, sy, rot : real; tx, ty : ScaledPts);
  353. var
  354.       (* coords of full bbox for transformation [n/s][e/w][x/y] *)
  355.    nex, ney, sex, sey, swx, swy, nwx, nwy: ScaledPts; 
  356.    temp1, temp2 : integer;
  357. begin
  358.   (* describe  and transform the bbox *)
  359.   nwx := round (minx * sx);      nex := round (maxx * sx);
  360.   sex := round (maxx * sx);      swx := round (minx * sx);
  361.   ney := round (maxy * sy);      nwy := round (maxy * sy);
  362.   swy := round (miny * sy);      sey := round (miny * sy);
  363.   
  364.   ptrotate (nex, ney, midx, midy, rot);
  365.   ptrotate (sex, sey, midx, midy, rot);
  366.   ptrotate (swx, swy, midx, midy, rot);
  367.   ptrotate (nwx, nwy, midx, midy, rot);
  368.   
  369.   nex := nex + tx; sex := sex + tx;
  370.   swx := swx + tx; nwx := nwx + tx;
  371.   ney := ney + ty; sey := sey + ty;
  372.   swy := swy + ty; nwy := nwy + ty;
  373.   (* now find the actual extents of the bbox *)
  374.   temp1 := min (nex, nwx);
  375.   temp2 := min (swx, sex);
  376.   minx := min (temp1, temp2);
  377.   
  378.   temp1 := min (ney, nwy);
  379.   temp2 := min (swy, sey);
  380.   miny := min (temp1, temp2);
  381.     
  382.   temp1 := max (nex, nwx);
  383.   temp2 := max (swx, sex);
  384.   maxx := max (temp1, temp2);
  385.   
  386.   temp1 := max (ney, nwy);
  387.   temp2 := max (swy, sey);
  388.   maxy := max (temp1, temp2);      
  389. end;
  390.       
  391.      
  392. {-----------------------------------------------}
  393. (* find the bounding box of the list of primitives  
  394.     and/or sub-figures in this Item *)
  395.  
  396. procedure findBBox (blot : pItem; 
  397.                 var mnx, mxx, mny, mxy : ScaledPts);
  398. var 
  399.    pi : pItem;
  400.    bmnx, bmxx, bmny, bmxy, midx, midy : ScaledPts; (* bbox [min/max][x/y] *)
  401.    tmnx, tmxx, tmny, tmxy : ScaledPts;  (* temporary, in case of recursion *)
  402.    null1, null2 : ScaledPts;
  403.    prescale, postscale : real;
  404.    old1, old2 : ScaledPts;
  405. begin
  406.   bmnx := TWO24; bmny := TWO24;
  407.   bmxx := -TWO24; bmxy :=-TWO24;
  408.   if (blot^.kind = Afigure) then
  409.     begin (* afigure *)
  410.     pi := blot^.body^.things;
  411.     while (pi <> nil) do
  412.       begin (* find the current bbox of the list of items here *)
  413.       if (pi^.kind = Afigure) then
  414.         begin  (* recur *)
  415.         findBBox (pi, tmnx, tmxx, tmny, tmxy);
  416.         bmnx := min (bmnx, tmnx);
  417.         bmny := min (bmny, tmny);
  418.         bmxx := max (bmxx, tmxx);
  419.         bmxy := max (bmxy, tmxy);
  420.         end
  421.       else
  422.         begin
  423.         bmnx := min (bmnx, pi^.BBlx);
  424.         bmny := min (bmny, pi^.BBby);
  425.         bmxx := max (bmxx, pi^.BBrx);
  426.         bmxy := max (bmxy, pi^.BBty);
  427.         end;
  428.       pi := pi^.nextitem;
  429.       end;  (* while *)
  430.         (* now transform the items inside, AND the bbox *)
  431.     pi := blot^.body^.things;
  432.     midx := (bmnx + bmxx) div 2;
  433.     midy := (bmny + bmxy) div 2;
  434.     (* now take care of any pre and post size requirements *)
  435.     (* see also the "figurehandle" proc. *)
  436.      with blot^ do
  437.       begin  
  438. (* ### Keep this scaling biz here, too, for now. May blast it later *)
  439.       if ((preWid <> 0) and (preHt <> 0)) then
  440.     begin
  441.     prescale := scalefitfactor ((bmxx - bmnx), (bmxy - bmny), preWid, preHt);
  442.     fsx := fsx * prescale;
  443.     fsy := fsy * prescale;
  444.     end;
  445.       if ((postWid <> 0) and (postHt <> 0)) then
  446.     begin
  447.     postscale := scalefitfactor ((bmxx - bmnx), (bmxy - bmny), postWid, postHt);
  448.     fsx := fsx * postscale;
  449.     fsy := fsy * postscale;
  450.     end;
  451.  
  452. (* the actual scale-up is taken care of later in this proc. *)
  453.       end; (* with *)  
  454.     while (pi <> nil) do
  455.       begin
  456.       with pi^ do
  457.         begin
  458.         case (kind) of
  459.           Aline : begin
  460.                   xfmlinepts (lx1, ly1, lx2, ly2, 0, 0, midx, midy, 1.0, 
  461.                         blot^.figtheta, blot^.fdx, blot^.fdy,
  462.                         blot^.fsx, blot^.fsy);
  463.                   end;
  464.           Aspline : begin
  465.                     xfmcontpts (spts, nsplknots, 0, 0, midx, midy, 1.0,
  466.                         blot^.figtheta, blot^.fdx, blot^.fdy,
  467.                         blot^.fsx, blot^.fsy);
  468.                     end;
  469.           Attspline : begin
  470.                       xfmcontpts (ttpts, nttknots, 0, 0, midx, midy, 1.0,
  471.                         blot^.figtheta, blot^.fdx, blot^.fdy,
  472.                         blot^.fsx, blot^.fsy);
  473.                       end;
  474.       Aarc : begin
  475.          null1 := 0; null2 := 0;
  476.          old1 := acentx; old2 := acenty;
  477.            xfmlinepts (acentx, acenty, null1, null2, 0,0, midx, midy, 1.0,
  478.                         blot^.figtheta, blot^.fdx, blot^.fdy,
  479.                         blot^.fsx, blot^.fsy);
  480.            xfmcontpts (arcpts, narcknots + 1, 0, 0, old1, old2, 1.0,
  481.                         blot^.figtheta, 
  482.             blot^.fdx + (acentx - old1),
  483.             blot^.fdy + (acenty - old2),
  484.                         blot^.fsx, blot^.fsy);
  485.                  end;              
  486.       Alabel : begin
  487.            null1 := 0; null2 := 0;
  488.              xfmlinepts (labx, laby, null1, null2, 0,0, midx, midy, 1.0,
  489.                         blot^.figtheta, blot^.fdx, blot^.fdy,
  490.                         blot^.fsx, blot^.fsy);        
  491.            end;
  492.           Abeam : ;   (* not transformable *)
  493.  
  494.           Atieslur: ; (* not transformable *)
  495.           Afigure : ; (* do not need to re-transform *)
  496.         end; (* case *)
  497.       end; (* with *)
  498.       pi := pi^.nextitem;
  499.       end;  (* while *)
  500.     (* transform the bbox, and re-find the new bbox *)
  501.     newbbox (bmnx, bmxx, bmny, bmxy, midx, midy, blot^.fsx, blot^.fsy,
  502.                 blot^.figtheta, blot^.fdx, blot^.fdy);
  503.     mnx := bmnx; mny := bmny;
  504.     mxx := bmxx; mxy := bmxy;
  505.     end  (* if *)
  506.   else (* some other primitive *)
  507.     begin
  508.     mnx := blot^.BBlx; mny := blot^.BBby;
  509.     mxx := blot^.BBrx; mxy := blot^.BBty;
  510.     end;  (* else *)
  511. end;  (*  findBBox *)
  512.  
  513.  
  514. {---------------------------------------------------------}
  515. (* traverse the list, determining the current bounding box for
  516.  *       the items. We need this to find the mid-point
  517.  *       for doing any remaining rotations 
  518.  *)
  519. procedure traverse (thefig, theitem : pItem);
  520. var 
  521.     minx, maxx, miny, maxy : ScaledPts;  
  522.     curminx, curmaxx, curminy, curmaxy : ScaledPts;  
  523. begin
  524.   minx := TWO24; maxx := -TWO24;
  525.   miny := TWO24; maxy := -TWO24;
  526.   
  527.   while (theitem <> nil) do
  528.     begin
  529.     if (theitem^.kind = Afigure) then
  530.       begin (* recur *)
  531.       findBBox (theitem, curminx, curmaxx, curminy, curmaxy);
  532.       with theitem^ do
  533.         begin
  534.         BBlx := curminx;         BBby := curminy;
  535.         BBrx := curmaxx;         BBty := curmaxy;
  536.            (* reset the symbol's parameters since all the
  537.                 primitives in it have now been transformed
  538.                 according to the previous specifications *)
  539.         figtheta := 0.0; 
  540.         fsx := 1.0;      fsy := 1.0;
  541.         fdx := 0;        fdy := 0;
  542.     preWid := 0;     preHt := 0;
  543.     postWid := 0;     postHt := 0;
  544.         end;  (* with *)
  545.       minx := min (minx, curminx);      miny := min (miny, curminy);
  546.       maxx := max (maxx, curmaxx);      maxy := max (maxy, curmaxy);
  547.       end  (* if a figure/symbol*)
  548.     else
  549.       begin  (* a primitive *)
  550.       with theitem^ do 
  551.         begin
  552.         minx := min (minx, BBlx);        miny := min (miny, BBby);
  553.         maxx := max (maxx, BBrx);        maxy := max (maxy, BBty);
  554.         end;  (* with *)
  555.       end;  (* else *)
  556.     theitem := theitem^.nextitem;
  557.     end;  (* while *)
  558.  
  559.   with thefig^ do
  560.     begin  (* set the bounding box for this upper-level symbol defn *)
  561.     BBlx := minx;
  562.     BBby := miny;
  563.     BBrx := maxx;
  564.     BBty := maxy;
  565.     end;  (* with *)
  566. end;  (* traverse *)
  567.  
  568. (* ----- Figure symbols ----- *)
  569. {---------------------------------------------------}
  570. procedure figurehandle (globalsymlist, symbollist : pItem; dopush : integer);
  571. const DoItNow = -1;
  572.       NoScale = 1;
  573. var pi, curfig : pItem;
  574.     midx, midy : ScaledPts;
  575.     null1, null2 : ScaledPts;
  576.     prescale, postscale : real;
  577.     tmnx, tmny, tmxx, tmxy : ScaledPts;
  578. begin (* figurehandle *)
  579.  
  580.     (* PUSH. traverse the lists (recursively if necessary) and 
  581.      * compute the transformed points.
  582.      * Convert to 4th quadrant and offset by H & V.
  583.      * We can do this destructively here
  584.      * since we're going to output them right away anyhow.
  585.      * Then call each respective primitive handler with a level
  586.      * of -1 to indicate  to do its job immediately. 
  587.      * POP.     
  588.      *)
  589.   curfig := symbollist;
  590.   pi := curfig^.body^.things;
  591.         (* find and set the bounding box for
  592.          the figure's sub-symbols and primitives *)
  593.   if (dopush > 0) then
  594.     traverse (curfig, pi); 
  595.   
  596.       (* We eventually transform the items
  597.      to 4th Quadrant DVI space and output them! *)
  598.  
  599.   pi := curfig^.body^.things;
  600.  
  601.   midy := (globalsymlist^.BBby + globalsymlist^.BBty) div 2;
  602.   midx := (globalsymlist^.BBlx + globalsymlist^.BBrx) div 2;
  603.  
  604.   if (dopush > 0) then 
  605.     begin (* the top-level figure for outputting *)
  606.  
  607.     (* convert the bounding box because we are about to enter
  608.         into DVI space, and all calls to handlers hereafter
  609.     are in terms of DVI coordinates *)
  610.  
  611.       with globalsymlist^ do
  612.         begin 
  613.  
  614. (* Since there were external specifications about this figure,
  615.     fit the current figure's actual size to the 
  616.     "pre" size (specified by W marker) and/or to the
  617.     "post" size (specified by the F marker). 
  618.     We do this by simple scaling, *without* changing the midpoint
  619.     of the bounding box, just its extents
  620.  *)
  621.     if ((preWid <> 0) and (preHt <> 0)) then
  622.       begin
  623.       prescale := scalefitfactor ((BBrx - BBlx), (BBty - BBby), preWid, preHt);
  624.       fsx := fsx * prescale;
  625.       fsy := fsy * prescale;
  626.       end;
  627.     if ((postWid <> 0) and (postHt <> 0)) then
  628.       begin
  629.       postscale := scalefitfactor ((BBrx - BBlx), (BBty - BBby), postWid, postHt);
  630.       fsx := fsx * postscale;
  631.       fsy := fsy * postscale;
  632.       end;
  633.     tmnx := BBlx; tmny := BBby; tmxx := BBrx; tmxy := BBty;
  634.     xfmlinepts (tmnx, tmny, tmxx, tmxy, 0,0, midx, midy, 1.0,
  635.             0.0, 0, 0, fsx, fsy);
  636.  
  637.     toplevelxfm (globalsymlist, globalsymlist, 0);
  638.     
  639.     dviBBlx := tmnx; 
  640.     dviBBrx := tmxx; 
  641.     dviBBby := tmny;
  642.     dviBBty := tmxy;
  643.  
  644.     xfmlinepts (dviBBlx, dviBBby, dviBBrx, dviBBty, 0,0,
  645.         midx, midy, 1.0, 0.0,
  646.         - (tmnx - BBlx), - (tmny - BBby),
  647.         1.0, 1.0);
  648.  
  649.     fdx := fdx - (tmnx - BBlx);
  650.     fdy := fdy - (tmny - BBby);
  651.     end;
  652.  
  653.       dvilinepts (dviBBlx, dviBBby, dviBBrx, dviBBty, h, v);
  654.       pgfigurenum := pgfigurenum + 1;
  655.  
  656.     (* We are ready to output the figure to the page *)
  657.       writeln(logfile);
  658.       write(logfile,'Figure #',pgfigurenum:0,' on page ',currpagenum:0,' is approx. ');
  659. {      write(logfile,((globalsymlist^.BBty - globalsymlist^.BBby) div SPPERPT):0,' pts high and ');
  660.       writeln(logfile,((globalsymlist^.BBrx - globalsymlist^.BBlx) div SPPERPT):0,' pts wide (actual size)');
  661. }
  662.     write(logfile,((tmxy - tmny) div SPPERPT):0,' pts high and ');
  663.     writeln(logfile,((tmxx - tmnx) div SPPERPT):0,' pts wide (actual size)');
  664.       IPUSH;  
  665.  
  666.     end;
  667.  
  668.   while (pi <> nil) do
  669.     begin
  670.     with pi^ do
  671.         begin
  672.         case (kind) of
  673.           Aline : begin
  674.                  dvilinepts (lx1, ly1, lx2, ly2, h, v); (* DVI h and v posit *)
  675.                  with globalsymlist^ do
  676.                  linehandle (DoItNow, NoScale, 
  677.                                 pi^.lx1, pi^.ly1, pi^.lx2, pi^.ly2,
  678.                                 0, 0,  
  679.                                 pi^.itemthick, pi^.itemvec, pi^.itempatt,
  680.                 dviBBlx, dviBBrx, dviBBby, dviBBty,
  681.                                 fdx, -fdy, fsx, fsy, -figtheta);
  682.                  end; (* Aline *)
  683.          
  684.          Aspline : begin
  685.                    dvicontpts (spts, nsplknots, h, v);
  686.                    with globalsymlist^ do
  687.                    splinehandle (DoItNow, NoScale, pi^.spltype, 
  688.                    pi^.sclosed, pi^.dosmarks,
  689.                                 pi^.spts, pi^.nsplknots,
  690.                                 0, 0,
  691.                                 pi^.itemthick, pi^.itemvec, pi^.itempatt,
  692.                                 dviBBlx, dviBBrx, dviBBby, dviBBty,
  693.                                 fdx, -fdy, fsx, fsy, -figtheta);
  694.                   end; (* Aspline *)
  695.          
  696.           Attspline : begin
  697.                    dvicontpts (ttpts, nttknots, h, v);
  698.                    with globalsymlist^ do
  699.                    ttsplhandle (DoItNow, NoScale, pi^.tspltype, 
  700.                    pi^.tclosed, pi^.dottmarks,
  701.                                 pi^.ttpts, pi^.ttarry, pi^.nttknots,
  702.                                 0, 0,
  703.                                 pi^.itemvec, pi^.itempatt,
  704.                                 dviBBlx, dviBBrx, dviBBby, dviBBty,
  705.                                 fdx, -fdy, fsx, fsy, -figtheta);
  706.                   end; (* Attspline *)
  707.  
  708.           Abeam : begin 
  709.                   dvilinepts (bx1, by1, bx2, by2, h, v);
  710.                   beamhandle (DoItNow, staf, bkind, bx1, by1, bx2, by2);
  711.                   end; (* Abeam *)
  712.  
  713.           Atieslur : begin
  714.                      dvicontpts (tspts, ntknots, h, v);
  715.                      tieslurhandle (DoItNow, tspts, ntknots, minth, maxth);
  716.                      end;  (* a tie or slur *)
  717.  
  718.       Aarc : begin
  719.                    dvicontpts (arcpts, narcknots + 1, h, v);
  720.                    with globalsymlist^ do
  721.                    arccirclehandle (DoItNow, NoScale,
  722.                 pi^.acentx, pi^.acenty,
  723.                 pi^.aradius,
  724.                 pi^.firstang, pi^.lastang,
  725.                 pi^.arcpts, pi^.narcknots,
  726.                 0, 0,
  727.                 pi^.itemthick, pi^.itemvec, pi^.itempatt,
  728.                                 dviBBlx, dviBBrx, dviBBby, dviBBty,
  729.                 fdx, -fdy, fsx, fsy, -figtheta);
  730.            end; (* arc *)
  731.       Alabel : begin
  732.              null1 := 0; null2 := 0;
  733.              dvilinepts (labx, laby, null1, null2, h, v);
  734.            with globalsymlist^ do
  735.            labelhandle (DoItNow, NoScale,
  736.                    pi^.labx, pi^.laby, 
  737.                 0, 0,
  738.                 pi^.fontstyle, pi^.labeltext,
  739.                 fdx, -fdy);
  740.           end; (* label *)
  741.  
  742.           Afigure : begin (* recur *)
  743.                     figurehandle (globalsymlist, pi, 0);
  744.                     end; (* another symbol *)
  745.  
  746.         end; (* case *)
  747.       end; (* with *)
  748.     pi := pi^.nextitem;
  749.     end; (* while *)
  750.   if (dopush > 0) then 
  751.     begin
  752.     IPOP;
  753.     end;
  754. end;  (*  figurehandle *)
  755.  
  756.  
  757.  
  758. (* %%% *)
  759. {-----------------------------------------------------}
  760. procedure mainhandlespecials (specnum, numpbytes : integer);
  761. (* specnum is the DVI-number of the special
  762.  * numpbytes is the number of parameter bytes
  763.  *)
  764. label 888;
  765. const PARSLEN = 50;  (* Length of the byte-string-cache *)
  766.       EMPTY = 0;
  767. type charset = set of char;
  768. var siz, numknots : integer;  (* Lots of temp vars that we use *)
  769.      x1, y1, x2, y2 : integer;
  770.      sx100, sy100 : real;
  771.      transx, transy : ScaledPts;
  772.      rot : real;
  773.      SPscale : real;
  774.      cpts : ControlPoints;
  775.      thk : VThickness;
  776.      patt : LineStyle;
  777.      TTary : ThickAryType;
  778.      vk : VectKind;
  779.      bk : BeamKind;
  780.      markdiam : integer;
  781.      radius, ang1, ang2 : integer;
  782.      phrase : strng;
  783.      style : integer;
  784.      nam : strng;
  785.      sysnam : strng;    (* the first parameter of the \special *)
  786.      let : char;
  787.      i, gotten : integer;
  788.      b : OctByt;
  789.      pi : pItem;
  790.      minx, miny, maxx, maxy : ScaledPts;
  791.      maxthk, minthk : integer;
  792.  
  793.      tylnam,
  794.      beginfigurenam,    (* names used for string to string comparisons *)
  795.      endfigurenam,
  796.      linenam,
  797.      splinenam,
  798.      ttsplnam,
  799.      beamnam,
  800.      tieslurnam,
  801.      arcnam,
  802.      labelnam,
  803.      paramnam {internal} : charstring;
  804.  
  805.      splinetype : SplineKind;
  806.      isclosedspline : boolean;
  807.  
  808.      parsearray : array [1..PARSLEN] of OctByt; (* cache of bytes to run through *)
  809.      parsposit, parsmax : integer; (* current and max position in cache *)
  810.      usingstream : boolean;    (* whether we read/parse using cache or from file *)
  811.  
  812.  
  813. (*--------------------------------------------------------------
  814.       These procedures depend on the correct ordering of
  815.       GETs with respect to the number of bytes read in so far.
  816.       precond: byte "b" has been read and gotten < numpbytes
  817.       postcond: byte "b" has been read iff gotten < numpbytes.
  818.       If your impl. definition of READ is non-standard, you will
  819.       have to dink with the ordering and be really careful of
  820.       keeping track of 'gotten' and 'numpbytes' variables 
  821. --------------------------------------------------------------*)      
  822.  
  823.         function nextpbyte : integer;
  824.         begin
  825.           if (usingstream) then
  826.             begin
  827.             if (gotten < numpbytes) then
  828.               begin
  829.               nextpbyte := Dget1byte; 
  830.               gotten := gotten + 1;
  831.               end
  832.             else
  833.               nextpbyte := EMPTY;
  834.             end
  835.           else
  836.             begin (* not using stream *)
  837.             if (parsposit <= parsmax) then
  838.               begin
  839.               nextpbyte := parsearray[parsposit];
  840.               parsposit := parsposit + 1;
  841.               end
  842.             else
  843.               begin     (* at end of parse array, so read from stream now *)
  844.               usingstream := true;
  845.               if (gotten < numpbytes) then
  846.                 begin
  847.                 nextpbyte := Dget1byte;
  848.                 gotten := gotten + 1;
  849.                 end
  850.               else
  851.                 nextpbyte := EMPTY;
  852.               end;
  853.             end;  (* else *)
  854.         end;        
  855.         
  856. (* !!!!! Make sure all these predicates jive correctly with
  857.     the key-letter definitions          *) 
  858. {__________________________________________________________________}
  859.         function isanumber (b : integer) : boolean;
  860.         begin
  861.           isanumber :=  ((b >= xord['0']) and (b <= xord['9']));
  862.         end;
  863.         
  864.         function isaletter (b : integer) : boolean;
  865.         begin
  866.           isaletter := (((b >= xord['A']) and (b <= xord['Z'])) or
  867.                         ((b >= xord['a']) and (b <= xord['z'])) or
  868.              (b = xord['@']) or
  869.              (b = xord['"']) );
  870.         end;
  871.         
  872.         function isaspace (b : integer) : boolean;
  873.         begin
  874.           isaspace := ((b = xord[' ']) or 
  875.                  (b = CR) or
  876.                (b = LF) or
  877.                (b = HT) or
  878.                (b = FF));
  879.         end;
  880.         
  881.         function isdelimiter (b : integer) : boolean;
  882.         begin
  883.           (* not a key-letter *)
  884.           isdelimiter := (((b < xord['A']) or (b > xord['Z'])) and
  885.                          ((b < xord['a']) or (b > xord['z'])) and
  886.              (b <> xord['@']) and
  887.              (b <> xord['"']) );
  888.         end;
  889.       
  890.         function isnotnull (b : integer) : boolean;
  891.         begin
  892.           isnotnull := (b <> EMPTY);
  893.         end;
  894.         
  895.         
  896. {__________________________________________________________________}
  897.         function getnumber : integer;
  898.         var n : integer;
  899.             isneg : boolean;
  900.         begin
  901.           n := 0;
  902.           isneg := false;
  903.           while (  (isnotnull (b)) and
  904.                   (not (isanumber (b)))) do
  905.             begin       (* not a numeral *)
  906.             if (b = xord['-']) then
  907.               isneg := true;
  908.             b := nextpbyte;
  909.             end;
  910.     
  911.       while (isaspace (b)) do  (* Skip spaces *)
  912.         b := nextpbyte;
  913.  
  914.           while ( (isnotnull (b)) and
  915.                  isanumber (b)) do
  916.             begin (* a numeral *)
  917.             n := n * 10 + (b - xord['0']);
  918.             b := nextpbyte;
  919.             end;
  920.  
  921.           if ((gotten = numpbytes)  and
  922.                  isanumber (b)) then
  923.             begin  (* end condition *)
  924.             n := n * 10 + (b - xord['0']);
  925.             end; 
  926.  
  927.           if (isneg) then
  928.             getnumber := -(n)
  929.           else
  930.             getnumber := n;
  931.         end;
  932. {__________________________________________________________________}
  933.  
  934.         function getletter : char;
  935.         var k : char;
  936.         begin
  937.           k := ' ';
  938.           while ( (isnotnull (b)) and
  939.                    (isdelimiter (b) and not (isaspace (b)))) do
  940.             begin (* non letter *)
  941.             b := nextpbyte;
  942.             end;
  943.  
  944.          if  ( (isnotnull (b)) and
  945.                 ( isaletter (b) or isaspace (b)
  946.                  and not (isanumber (b)))) then
  947.           begin
  948.             k := xchr[b];
  949.             b := nextpbyte;
  950.           end;
  951.         getletter := k;
  952.         end;
  953. {__________________________________________________________________}
  954.  
  955.         function getanything : char;
  956.         var k : char;
  957.         begin
  958.           k := ' ';
  959.           while (not (isnotnull (b))) do
  960.             begin (* not usable *)
  961.             b := nextpbyte;
  962.             end;
  963.  
  964.          if (isnotnull (b)) then
  965.           begin
  966.             k := xchr[b];
  967.             b := nextpbyte;
  968.           end;
  969.         getanything := k;
  970.         end;
  971.  
  972. {****************************************************
  973.    The following routines look for key - letter tokens
  974.   that indicate certain attributes for a primitive.
  975.  
  976. Currently, the letters used are:
  977.     S    for scaled-points measurement
  978.     P    for printers points
  979.     M    millimeters measurement
  980.     C    use a Circular vector for drawing
  981.     H    Horizontal-pen vector
  982.     V    Vertical vector
  983.     B    B-spline
  984.     I    Interpolating B-spline
  985.     K    Catmull-Rom spline
  986.     D    Cardinal spline
  987.     U    Open spline
  988.     O    closed spline
  989.     X    put marks on spline control pts
  990.     T    Transformation marker
  991.     R    Regular beam characters
  992.     G    Grace Beam characters
  993.     @    Specify center-point for arc/circle
  994.     L    Line-style 
  995.     F    for beginfigure: Fit figure to wid/ht
  996.     W    for beginfigure: figure was created at this wid & ht
  997. **************************************************}
  998.  
  999.  
  1000. {__________________________________________________________________}
  1001.